home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / graphics / escher.arc / CUBED.BAS next >
BASIC Source File  |  1987-05-04  |  30KB  |  587 lines
  1. 100   '***************************** ESCHER CUBES ******************************
  2. 110   '***************************** By Jim Luczak *****************************
  3. 120   '*************************** Ver 1.4d  2/6/87 ****************************
  4. 130   dim mhl(26),cl0(15),cl1(15),cl2(15),cl3(15),tx(56),titlep(10),ctx$(10)
  5. 140   max=5000:dim ps(5000),fv(10),fm(4):path=0:icon=3:priority=2
  6. 150   a#=gb:gintin=peek(a#+8):gintout=peek(a#+12):pl#=1114
  7. 160   addrin=peek(a#+16):path$="\*.CUB":path1$=path$+string$(24,chr$(0))
  8. 170   test$="\"+chr$(14)+chr$(15):button$="CANCEL|DELETE":button1$=button$
  9. 180   box$="Verify DELETE Operation":box1$=box$
  10. 190   if peek(systab)=4 then goto LOWREZMSG
  11. 200   if peek(systab)=2 then restore MEDREZ
  12. 210   if peek(systab)=1 then restore HIREZ 
  13. 220   read v1,v2,v3,v4,v5,st,t1,t2,cm1,cm2,j,j1,txty,rz,dfy,dth,ta,mkc1
  14. 230   read y7,y8,y12,y13,ta2,ta3,ta4,ta5
  15. 240   for x=1 to 4:read fm(x):next x
  16. 250   for x=1 to 10:read fv(x):next x
  17. 260   for x=0 to 15:read cl0(x):next x
  18. 270   for x=0 to 15:read cl1(x):next x
  19. 280   for x=0 to 15:read cl2(x):next x
  20. 290   for x=0 to 15:read cl3(x):next x 
  21. 300   restore CBARDAT
  22. 310   for x=1 to 26:read mhl(x):next x
  23. 320   for x=0 to 56:read tx(x):next x
  24. 330   for x=0 to 10:read titlep(x):next x
  25. 340   restore CNTDATA
  26. 350   for x=1 to 9:read ctx$(x):next x
  27. 360   ctx$(10)=chr$(14)+chr$(15)+"  Exit Program  "+chr$(14)+chr$(15)
  28. 370   sz=4:a=cm1*sz:b=cm2*sz:c=3*sz:sd=4:sd1=4
  29. 380   dfx=304:lv=-1:lh=0:mkc2=3:c1=1:c2=2:c3=3
  30. 390   ind=2:st1=st:ts=30/j:rzm=1:lc=3:lc1=1:lc2=2:cl$=space$(50)
  31. 400   title$=chr$(32)+chr$(1)+chr$(32)+chr$(2)+chr$(32)+chr$(3)+chr$(32)+chr$(4)
  32. 410   title$=title$+chr$(32)+chr$(t1)+chr$(32)+chr$(t2)
  33. 420   title$=title$+"  Col=  0  Bkg=  0  Fill=     Erase OFF  Clear  "
  34. 430   title$=title$+"Size=  4  "+chr$(8)+chr$(32)+chr$(0)
  35. 440   tlt1$=chr$(32)+chr$(14)+chr$(15)+" Escher Cubes File Control "
  36. 450   tlt1$=tlt1$+chr$(14)+chr$(15)+chr$(32)+chr$(0)
  37. 460   tlt2$=" 1= "+chr$(1)+"  2= "+chr$(2)+"  3= "+chr$(3)+"  4= "+chr$(4)
  38. 470   tlt2$=tlt2$+"  5= "+chr$(t1)+"  6= "+chr$(t2)
  39. 480   tlt2$=tlt2$+"      7= Col"+chr$(1)+"  8= Bkg"+chr$(1)+"  9= Fill"
  40. 490   tlt2$=tlt2$+chr$(1)+chr$(32)+chr$(0)
  41. 500   tlt3$=" Escher Cubes "+chr$(0)
  42. 510   eds$="  10= Erase ON/OFF  11= Clear  12= Size"+chr$(1)
  43. 520   eds$=eds$+"  14= Col"+chr$(2)+" 16= Bkg"+chr$(2)+"  18= Fill"+chr$(2)
  44. 530   eds1$="  24= Size"+chr$(2)+"  -1= Place Cube  XXX  YYY  -2= NUL"
  45. 540   eds1$=eds1$+"  -3= End  -4= Hi  -8= Lo"
  46. 550   gosub TITLEPAGE:poke systab+24,1:gosub SETCOLOR
  47. 560   txsz=56:txtx=161:gosub DOTEXT:gosub DOCONTROLS
  48. 570   restore CUBEP:gosub MOUSEFORM 
  49. 580   x=dfx:y=dfy:mx1=dfx:my1=dfy:x1=dfx:y1=dfy
  50. 590   '----------------------------- MOUSE CONTROLLER -------------------------
  51. 600   gosub MOUSEON
  52. 610   mk=0:hc1=-2:while mk=0
  53. 620   poke contrl,124:poke contrl+2,0:poke contrl+6,0:vdisys(1)
  54. 630   mx=peek(ptsout):my=peek(ptsout+2):mkey=peek(intout)
  55. 640   if mkey=1 or mkey=2 then gosub CHECKMOUSE
  56. 650   if hc1>0 and hc1<7 then gosub DOCUBE
  57. 660   if hc1>6 and hc1<14 then gosub CONTROLBAR
  58. 670   if hc1=14 then mx=mx1:my=my1:hc1=-1
  59. 680   if hc1=15 then mx=x1:my=y1:hc1=-1
  60. 690   if mkey=2 then hc1=-2:gosub COORD
  61. 700   if hc1=-1 then gosub PLACECUBE
  62. 710   hc1=-2:wend
  63. 720   '--------------------------- CLEAN-UP AND END ---------------------------
  64. 730   CLEANUP:gosub MOUSEOFF
  65. 740   clearw 2:poke systab+24,0:tlt=1:title$=" OUTPUT "+chr$(0)
  66. 750   gosub DOCONTROLS:plt%(0)=1911:plt%(1)=1792:plt%(2)=112:plt%(3)=0
  67. 760   poke pl#,varptr(plt%(0)):color 1,1,1
  68. 770   restore DEFAULTP:gosub MOUSEFORM:clear:end
  69. 780   '------------------------ LOW RESOLUTION MESSAGE -----------------------
  70. 790   LOWREZMSG:icon=1:priority=1:box1$=" |":fullw 2:clearw 2
  71. 800   box$=chr$(14)+chr$(15)+"  ESCHER CUBES  "+chr$(14)+chr$(15)+"|"
  72. 810   box$=box$+box1$+chr$(3)+" Set Preference To "+chr$(4)
  73. 820   button$=chr$(175)+"   MEDIUM RESOLUTION   "+chr$(174):gosub FORMBOX:end
  74. 830   '---------------------------- ERROR HANDLER -----------------------------
  75. 840   close #1:if dp=1 then dp=0:goto ERD
  76. 850   open "R",#1,f$,3:field #1,3 as am$:lset am$=a$:put #1,1:close #1:kill f$
  77. 860   ERD:?chr$(7);:resume GETANS1
  78. 870   '------------------------------- MOUSE ON -------------------------------
  79. 880   MOUSEON:poke gintin,257:gemsys(78):return
  80. 890   '------------------------------- MOUSE OFF ------------------------------
  81. 900   MOUSEOFF:poke gintin,256:gemsys(78):return
  82. 910   '-------------------------- CHECK MOUSE LOCATION ------------------------
  83. 920   CHECKMOUSE:
  84. 930   mc=0:hc=1:hc1=1:hct=26
  85. 940   if my<v1 then gosub MCC:return
  86. 950   if my>v2 then hc1=-1:return
  87. 960   while mc=0
  88. 970   if mx>=mhl(hc) and mx<=mhl(hc+1) then mc=1
  89. 980   if mc=0 then hc1=hc1+1
  90. 990   hc=hc+2:if hc>hct then mc=1
  91. 1000  wend:if hc1>hct/2 then hc1=-1
  92. 1010  return
  93. 1020  MCC:if mx>162 and mx<353 then hc1=14:return
  94. 1030  if mx>354 and mx<532 then hc1=15:return
  95. 1040  hc1=-2:return
  96. 1050  '----------------------- CONTROL BAR CONTROLLER -------------------------
  97. 1060  CONTROLBAR:
  98. 1070  on hc1-6 goto CB1,CB2,CB3,CB4,CB5,CB6,CB7
  99. 1080  CB1:if mkey=1 then cr1=cr1+1:if cr1>15 then cr1=0
  100. 1090  if mkey=2 then cr1=cr1-1:t=1:if cr1<0 then cr1=15
  101. 1100  gosub DOCUCOL:goto BARDONE
  102. 1110  CB2:if mkey=1 then cr0=cr0+1:if cr0>15 then cr0=0
  103. 1120  if mkey=2 then cr0=cr0-1:t=1:if cr0<0 then cr0=15
  104. 1130  gosub DOBCK:goto BARDONE
  105. 1140  CB3:if mkey=1 then gosub PATUP
  106. 1150  if mkey=2 then gosub PATDN
  107. 1160  gosub DOSTYLE:goto BARDONE
  108. 1170  CB4:gosub DOERASE:goto BARDONE
  109. 1180  CB5:gosub CLEARSCR:goto BARDONE
  110. 1190  CB6:if mkey=1 then sz=sz+1:if sz>12 then sz=1
  111. 1200  if mkey=2 then sz=sz-1:t=1:if sz<1 then sz=12
  112. 1210  gosub DOSIZE:goto BARDONE
  113. 1220  CB7:goto CNTSCREEN
  114. 1230  CB7A:ps(h)=hc1:gosub CLEARSCR:gosub PLAYBACK:goto BARD
  115. 1240  BARDONE:ps(h)=hc1:if t=1 then t=0:ps(h)=hc1*2
  116. 1250  h=h+1:if h>max then h=max:ps(h)=13
  117. 1260  BARD:mkey=1:return
  118. 1270  PATUP:st=st+1:if st>24 then st=1:ind=3
  119. 1280  if st>12 and ind=3 then ind=2:st=1
  120. 1290  return
  121. 1300  PATDN:st=st-1:t=1:if st<1 and ind=2 then ind=3:st=12
  122. 1310  if st<1 and ind=3 then ind=2:st=24
  123. 1320  return
  124. 1330  '--------------------------- CUBE CONTROLLER ----------------------------
  125. 1340  DOCUBE:gosub MOUSEOFF
  126. 1350  on hc1 goto UP,DOWN,RIGHT,LEFT,FORWARD,BACKWARD
  127. 1360  UP:y=y-b:gosub SETCUBE:gosub DOBOX:goto CUBEDONE
  128. 1370  DOWN:y=y+b:if hc2=3 then sd=4:sd1=3
  129. 1380  if hc2=6 then sd=3:sd1=4
  130. 1390  gosub SETCUBE:gosub FRONT:sd=sd1:gosub SIDE:goto CUBEDONE
  131. 1400  RIGHT:x=x+c:y=y-a:gosub SETCUBE
  132. 1410  if hc2=2 then sd=4:sd1=3:gosub SETRTOP
  133. 1420  if hc2=6 then sd=3:sd1=4:gosub SETRFRONT
  134. 1430  gosub FRONT:sd=sd1:gosub TOP:goto CUBEDONE
  135. 1440  LEFT:x=x-c:y=y+a:gosub SETCUBE:gosub DOBOX:goto CUBEDONE
  136. 1450  FORWARD:x=x+c:y=y+a:gosub SETCUBE:gosub DOBOX:goto CUBEDONE
  137. 1460  BACKWARD:x=x-c:y=y-a:gosub SETCUBE
  138. 1470  if hc2=2 then sd=3:sd1=4
  139. 1480  if hc2=3 then sd=4:sd1=3:gosub SETBSIDE
  140. 1490  gosub TOP:sd=sd1:gosub SIDE
  141. 1500  CUBEDONE:hc2=hc1:sd=4:sd1=4:gosub MOUSEON
  142. 1510  gosub DOSOUND:mkey=1:ps(h)=hc1
  143. 1520  h=h+1:if h>max then h=max:ps(h)=13
  144. 1530  return
  145. 1540  '----------------------------- PLACE CUBE -------------------------------
  146. 1550  PLACECUBE:x=mx:y=my*rzm:hc2=hc1
  147. 1560  if h+3>max then goto PL1
  148. 1570  ps(h)=hc1:ps(h+1)=mx:ps(h+2)=my
  149. 1580  gosub DOBOXA:gosub MOUSEON
  150. 1590  PL1:h=h+3:if h>max then h=max:ps(h)=13
  151. 1600  return
  152. 1610  '------------------------------ CLEAR SCREEN ----------------------------
  153. 1620  CLEARSCR:if t3<>1 then reset:gosub MOUSEOFF:clearw 2:gosub MOUSEON
  154. 1630  er=1:sz=4:st=st1:cr0=0:cr1=0:ind=2:gosub DOCUCOL
  155. 1640  x=dfx:y=dfy:mx1=dfx:my1=dfy:x1=dfx:y1=dfy
  156. 1650  gosub DOSIZE:gosub DOERASE:gosub DOBCK
  157. 1660  restore COORDTEXT:for z=0 to 5:read tx(z):next z   
  158. 1670  v6=v3:v3=0:v7=v4:v4=639:gosub SETCLIP:v3=v6:v4=v7
  159. 1680  txsz=56:txtx=161:gosub DOTEXT:gosub SETCLIP:return
  160. 1690  '---------------------------- DRAW WHOLE CUBE ---------------------------
  161. 1700  DOBOXA:gosub SETCUBE:gosub DOSOUND:gosub MOUSEOFF
  162. 1710  DOBOX:gosub FRONT:gosub TOP:gosub SIDE:return
  163. 1720  '--------------------------- DRAW CUBE TOP ---------------------------